home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / defs.lsp < prev    next >
Lisp/Scheme  |  1992-09-09  |  28KB  |  823 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (eval-when (compile load eval)
  31.   
  32. (defvar *defclass-times*   '(load eval))    ;Probably have to change this
  33.                         ;if you use defconstructor.
  34. (defvar *defmethod-times*  '(load eval))
  35. (defvar *defgeneric-times* '(load eval))
  36.  
  37. (defvar *boot-state* ())            ;NIL
  38.                         ;EARLY
  39.                         ;BRAID
  40.                         ;COMPLETE
  41.  
  42. )
  43.  
  44. (eval-when (load eval)
  45.   (when (eq *boot-state* 'complete)
  46.     (error "Trying to load (or compile) PCL in an environment in which it~%~
  47.             has already been loaded.  This doesn't work, you will have to~%~
  48.             get a fresh lisp (reboot) and then load PCL."))
  49.   (when *boot-state*
  50.     (cerror "Try loading (or compiling) PCL anyways."
  51.         "Trying to load (or compile) PCL in an environment in which it~%~
  52.              has already been partially loaded.  This may not work, you may~%~
  53.              need to get a fresh lisp (reboot) and then load PCL."))
  54.   )
  55.  
  56.  
  57.  
  58. ;;;
  59. ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
  60. ;;; function specs I wouldn't need this.  On the other hand, I don't like the
  61. ;;; way this really works so maybe function specs aren't really right either?
  62. ;;; 
  63. ;;; I also don't understand the real implications of a Lisp-1 on this sort of
  64. ;;; thing.  Certainly some of the lossage in all of this is because these
  65. ;;; SPECs name global definitions.
  66. ;;;
  67. ;;; Note that this implementation is set up so that an implementation which
  68. ;;; has a 'real' function spec mechanism can use that instead and in that way
  69. ;;; get rid of setf generic function names.
  70. ;;;
  71. (defmacro parse-gspec (spec
  72.                (non-setf-var . non-setf-case)
  73.                (setf-var . setf-case))
  74.   (declare (indentation 1 1))
  75.   (once-only (spec)
  76.     `(cond (#-setf (symbolp ,spec) #+setf t
  77.         (let ((,non-setf-var ,spec)) ,@non-setf-case))
  78.        ((and (listp ,spec)
  79.          (eq (car ,spec) 'setf)
  80.          (symbolp (cadr ,spec)))
  81.         (let ((,setf-var (cadr ,spec))) ,@setf-case))
  82.        (t
  83.         (error
  84.           "Can't understand ~S as a generic function specifier.~%~
  85.                It must be either a symbol which can name a function or~%~
  86.                a list like ~S, where the car is the symbol ~S and the cadr~%~
  87.                is a symbol which can name a generic function."
  88.           ,spec '(setf <foo>) 'setf)))))
  89.  
  90. ;;;
  91. ;;; If symbol names a function which is traced or advised, return the
  92. ;;; unadvised, traced etc. definition.  This lets me get at the generic
  93. ;;; function object even when it is traced.
  94. ;;;
  95. (defun unencapsulated-fdefinition (symbol)
  96.   #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
  97.   #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
  98.   #+excl  (or (excl::encapsulated-basic-definition symbol)
  99.           (symbol-function symbol))
  100.   #+xerox (il:virginfn symbol)
  101.   #+CLISP (or (get symbol 'sys::traced-definition) (symbol-function symbol))
  102.   #+setf (fdefinition symbol)
  103.   #-(or Lispm Lucid excl Xerox CLISP setf) (symbol-function symbol))
  104.  
  105. ;;;
  106. ;;; If symbol names a function which is traced or advised, redefine
  107. ;;; the `real' definition without affecting the advise.
  108. ;;;
  109. (defun fdefine-carefully (symbol new-definition)
  110.   #+Lispm (si:fdefine symbol new-definition t t)
  111.   #+Lucid (let ((lucid::*redefinition-action* nil))
  112.         (setf (symbol-function symbol) new-definition))
  113.   #+excl  (setf (symbol-function symbol) new-definition)
  114.   #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
  115.                 (brokenp (member symbol il:brokenfns :test #'eq)))
  116.         ;; In XeroxLisp (late of envos) tracing is implemented
  117.         ;; as a special case of "breaking".  Advising, however,
  118.         ;; is treated specially.
  119.             (xcl:unadvise-function symbol :no-error t)
  120.             (xcl:unbreak-function symbol :no-error t)
  121.             (setf (symbol-function symbol) new-definition)
  122.             (when brokenp (xcl:rebreak-function symbol))
  123.             (when advisedp (xcl:readvise-function symbol)))
  124.   #+CLISP (let ((traced (get symbol 'sys::traced-definition)))
  125.             (if traced
  126.               (if (consp traced)
  127.                 (progn
  128.                   (sys::untrace2 symbol)
  129.                   (setf (symbol-function symbol) new-definition))
  130.                 (setf (get symbol 'sys::traced-definition) new-definition))
  131.               (setf (symbol-function symbol) new-definition)))
  132.   #+setf (setf (fdefinition symbol) new-definition)
  133.   #-(or Lispm Lucid excl Xerox CLISP setf)
  134.   (setf (symbol-function symbol) new-definition)
  135.   
  136.   new-definition)
  137.  
  138. (defun gboundp (spec)
  139.   (parse-gspec spec
  140.     (name (fboundp name))
  141.     (name (fboundp (get-setf-function-name name)))))
  142.  
  143. (defun gmakunbound (spec)
  144.   (parse-gspec spec
  145.     (name (fmakunbound name))
  146.     (name (fmakunbound (get-setf-function-name name)))))
  147.  
  148. (defun gdefinition (spec)
  149.   (parse-gspec spec
  150.     (name (or #-setf (macro-function name)        ;??
  151.           (unencapsulated-fdefinition name)))
  152.     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
  153.  
  154. (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
  155.   (parse-gspec spec
  156.     (name (fdefine-carefully name new-value))
  157.     (name (fdefine-carefully (get-setf-function-name name) new-value))))
  158.  
  159.  
  160. (proclaim '(special *the-class-t* 
  161.                     *the-class-vector* *the-class-symbol*
  162.                     *the-class-string* *the-class-sequence*
  163.                     *the-class-rational* *the-class-ratio*
  164.                     *the-class-number* *the-class-null* *the-class-list*
  165.                     *the-class-integer* *the-class-float* *the-class-cons*
  166.                     *the-class-complex* *the-class-character*
  167.                     *the-class-bit-vector* *the-class-array*
  168.  
  169.                     *the-class-slot-object*
  170.                     *the-class-standard-object*
  171.                     *the-class-structure-object*
  172.                     *the-class-class*
  173.                     *the-class-method*
  174.                     *the-class-generic-function*
  175.                     *the-class-built-in-class*
  176.                     *the-class-slot-class*
  177.                     *the-class-structure-class*
  178.                     *the-class-standard-class*
  179.                     *the-class-funcallable-standard-class*
  180.                     *the-class-standard-method*
  181.                     *the-class-standard-generic-function*
  182.                     *the-class-standard-direct-slot-definition*
  183.                     *the-class-standard-effective-slot-definition*))
  184.  
  185. (proclaim '(special *the-wrapper-of-t*
  186.                     *the-wrapper-of-vector* *the-wrapper-of-symbol*
  187.                     *the-wrapper-of-string* *the-wrapper-of-sequence*
  188.                     *the-wrapper-of-rational* *the-wrapper-of-ratio*
  189.                     *the-wrapper-of-number* *the-wrapper-of-null*
  190.                     *the-wrapper-of-list* *the-wrapper-of-integer*
  191.                     *the-wrapper-of-float* *the-wrapper-of-cons*
  192.                     *the-wrapper-of-complex* *the-wrapper-of-c